home *** CD-ROM | disk | FTP | other *** search
/ SPACE 1 / SPACE - Library 1 - Volume 1.iso / program / 16 / art.fth < prev    next >
Text File  |  1985-11-19  |  3KB  |  128 lines
  1. \ String Art demo.  Load this file then type   stringart
  2. \ Typing any key stops the demo.
  3.  
  4. needs line-a-init linea.fth
  5. line-a-init
  6.  
  7. decimal
  8.  
  9. 13 constant #functions
  10. 343 constant #artlines
  11.  
  12. #functions #artlines * constant #points
  13.  
  14. create function-points  #points /w*  allot
  15.  
  16. 17 xbios: _random { -- l.rnd-number }  \ bios random number routine
  17.  
  18. : rnd  ( limit -- rndnum )  \ return random number up to limit
  19.    _random swap  mod
  20. ;
  21. : random ( -- n )  #functions rnd   ;
  22.  
  23. \ Get a new random number that is different from the old one
  24. : new-rand ( old-rand -- new-rand )
  25.    begin  random  ( old new )
  26.           2dup =
  27.    while  drop
  28.    repeat
  29.    nip
  30. ;
  31.  
  32. : write-binary-points ( -- )
  33.    [""] stringpt.bin dup make drop
  34.    write open ofd !
  35.    function-points  #points /w*  ofd @ fputs
  36.    ofd @ close
  37. ;
  38. defer test ' noop is test
  39.  
  40. \ Read the ascii version of the function tables and write it back out
  41. \ as a binary file
  42. : read-points ( -- )
  43.    [""] stringpt.num read open ifd !
  44.    hex
  45.    function-points  #points /w*
  46.    bounds
  47.    ?do
  48.       pad ifd @ getword  test
  49.       number? 0= abort" bogus"
  50.       i w!
  51.    /w +loop
  52.    ifd @ close
  53.    write-binary-points
  54. ;
  55.  
  56. \ Read in the binary version of the function tables
  57. : read-binary-points ( -- )
  58.    [""] stringpt.bin read open ifd !
  59.    function-points  #points /w*  tuck ifd @  fgets
  60.        <> if ." Read failed" cr then
  61.    ifd @ close
  62. ;
  63. variable xs   variable ys      \ Starting endpoint for a line
  64. variable xe   variable ye      \ Ending   endpoint for a line
  65.  
  66. \ Find the starting address for the index'th function in the function
  67. \ table
  68. : >function ( index -- table-address )
  69.    #artlines * /w*  function-points +
  70. ;
  71.  
  72. \ Coefficients for transforming to the screen coordinate system
  73. wvariable xscale  wvariable yscale
  74. wvariable xoffset wvariable yoffset
  75. : set-scaling ( -- )
  76.    get-rez  ( xmax ymax )
  77.    2dup
  78.    9 10 */ yscale w!
  79.    9 10 */ xscale w!  ( xmax ymax )
  80.    20 / yoffset w!
  81.    20 / xoffset w!
  82. ;
  83. \ Transform normalized device coordinates to screen coordinates
  84. code ndc>device ( x y -- x' y' )
  85.    sp )+ d1 move  \ y
  86.    sp )+ d0 move  \ x
  87.    xscale l#)  d0   mulu
  88.    yscale l#)  d1   mulu
  89.    d0 d0 add
  90.    d1 d1 add
  91.    d0 word clr normal
  92.    d0 swap
  93.    d1 word clr normal
  94.    d1 swap
  95.    word xoffset l#) d0 add normal
  96.    word yoffset l#) d1 add normal
  97.    d0 sp -) move
  98.    d1 sp -) move
  99. c;
  100.  
  101. : nextw ( variable -- w )
  102.    dup @ w@ /w rot +!
  103. ;
  104. : draw-line ( -- )
  105.    xs nextw ys nextw  ndc>device ( startxy )
  106.    xe nextw ye nextw  ndc>device ( startxy endxy )
  107.    draw
  108. ;
  109. : stringart
  110.    set-scaling
  111.    0 _wrt_mod w!
  112.    erase-screen
  113.    begin
  114.        random dup >function xs !      new-rand   >function xe !
  115.        random dup >function ys !      new-rand   >function ye !
  116.  
  117.        xs @ ys @ xe @ ye @
  118.          #artlines 0  do  draw-line  loop
  119.        ye ! xe ! ys ! xs !
  120.  
  121.        _fg_bp_1 w@  0  _fg_bp_1 w!
  122.          #artlines 0  do  draw-line  loop
  123.        _fg_bp_1 w!
  124.  
  125.    key? until
  126. ;
  127. read-binary-points
  128. ö}Γ~,~q~»~ΩM